Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/FMenus Example/PNL Libraries/MyFMenus.unit

Text File | 1992-11-24 | 6.8 KB | 290 lines | [TEXT/PJMM]

unit MyFMenus;

{ From Peter's PNL Libraries }
{ Copyright 1992 Peter N Lewis }
{ This source may be used for any non-commercial purposes as long as I get a mention }
{ in the About box and Docs of any derivative program.  It may not be used in any commercial }
{ application without my permission }

interface

    procedure InitFMenus (default: procptr);
{ procedure default(themenu,theitem:integer) }
{ Call this once at the start of the application, before all the others }
    procedure FinishFMenus;
{ Call this ones as the application quits }

    function GetFMenu (id: integer): MenuHandle;
{ Call this in place of GetMenu, to read in an fmnu resource.  Use InsertMenu to add it to the menu bar }
    procedure SetFCommand (command: OSType; cmdproc: procptr);
{ procedure cmdproc }
{ Call this to associate a procedure with a command OSType }
    procedure SetFSetMenu (command: OSType; smproc: procptr);
{ procedure smproc(themenu,theitem:integer) }
{ Call this to associate a procedure for enabling/disabling the menu item }
    procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
{ This is just a short form to set both the command and SetMenu procedures }

    procedure SetFMenus;
{ Call this before MenuKey or MenuSelect to set the enables of all the menus }
    procedure DoFMenu (themenu, theitem: integer);
{ Call this to act on a menu selection from either MenuSelect or MenuKey }

{ You probably won't need these }
    procedure AddFCommand (themenu, theitem: integer; command: OSType);
{ Call this to associate a menu item with an OSType - normally done by GetFMenu }
    procedure GetCommand (themenu, theitem: integer; var command: OSType);
{ Call this to figure out what command OSType is associated with a menu item - normally done via DoFMenu }
    procedure DoCommand (themenu, theitem: integer; command: OSType);
{ Call this to execute a menu command - normally done via DoFMenu }

implementation

    uses
        BaseGlobals;
{ import the quitNow variable - this is only used for cosmetic reasons, so that }
{ the File menu stays highlighted until the application quits }
{ Don't forget that you need to turn on the "Uses" Extensions in the Compile Options }

    procedure DoSMP (themenu, theitem: integer; smp: procptr);
    inline
        $205F, $4E90;

    procedure DoDefCMDP (themenu, theitem: integer; cmdp: procptr);
    inline
        $205F, $4E90;

    procedure DoCMDP (cmdp: procptr);
    inline
        $205F, $4E90;

    type
        fmenuHeader = record
                visible: integer;
                count: integer;
                unknown1: integer;
                menuID: integer;
                unknown2: integer;
                unknown3: integer;
                name: str63;
            end;
        fmenuHeaderPtr = ^fmenuHeader;
        fmenuItem = packed record
                command: OSType;
                mark: char;
                unknown2: byte;
                cmdKey: char;
                disabled: byte;
                name: str63;
            end;
        fmenuItemPtr = ^fmenuItem;
        convertRecord = record
                menu, item: integer;
                cmd: OSType;
                cmdp, smp: procptr;
            end;
        convertArray = array[1..1000] of convertRecord;
        convertPtr = ^convertArray;
        convertHandle = ^convertPtr;

    var
        defaultproc: procptr;
        convert_count: integer;
        converts: convertHandle;

{$S Init}
    procedure InitFMenus (default: procptr);
{ procedure default(themenu,theitem:integer) }
    begin
        defaultproc := default;
        convert_count := 0;
        converts := convertHandle(NewHandle(0));
    end;

{$S Term}
    procedure FinishFMenus;
    begin
        DisposHandle(handle(converts));
    end;

{$S Init}
    procedure AddFCommand (themenu, theitem: integer; command: OSType);
    begin
        if BAND(convert_count, 7) = 0 then
            SetHandleSize(handle(converts), (convert_count + 8) * SizeOf(convertRecord));
        convert_count := convert_count + 1;
        with converts^^[convert_count] do begin
            menu := themenu;
            item := theitem;
            cmd := command;
            cmdp := defaultproc;
            smp := nil;
        end;
    end;

{$S Init}
    procedure NextPtr (var p: univ ptr; sp: univ ptr);
    begin
        p := ptr(longInt(sp) + sp^ + 2 - ord(odd(sp^)));
    end;

{$S Init}
    function GetFMenu (id: integer): MenuHandle;
        var
            h: handle;
            mh: menuHandle;
            ph: fmenuHeaderPtr;
            p: fmenuItemPtr;
            s: string[70];
            i: integer;
    begin
        h := GetResource('fmnu', id);
        HLock(h);
        ph := fmenuHeaderPtr(h^);
        mh := NewMenu(ph^.menuID, ph^.name);
        NextPtr(p, @ph^.name);
        for i := 1 to ph^.count do begin
            if p^.name = '-' then
                AppendMenu(mh, '(-')
            else begin
                AddFCommand(ph^.menuID, i, p^.command);
                s := p^.name;
                if p^.mark <> chr(0) then
                    s := concat(s, '!', p^.mark);
                if p^.cmdKey <> chr(0) then
                    s := concat(s, '/', p^.cmdKey);
                if p^.disabled = 1 then
                    s := concat('(', s);
                AppendMenu(mh, s);
            end;
            NextPtr(p, @p^.name);
        end;
        ReleaseResource(h);
        GetFMenu := mh;
    end;

{$S}
    procedure FindCommand (command: OSType; var cmdproc: procptr);
        var
            i: integer;
    begin
        i := 1;
        while i <= convert_count do begin
            with converts^^[i] do
                if cmd = command then begin
                    cmdproc := cmdp;
                    Exit(FindCommand);
                end;
            i := i + 1;
        end;
        cmdproc := defaultproc;
    end;

{$S}
    procedure FindMenu (themenu, theitem: integer; var i: integer);
    begin
        i := 1;
        while i <= convert_count do begin
            with converts^^[i] do
                if (menu = themenu) and (item = theitem) then
                    Exit(FindMenu);
            i := i + 1;
        end;
        i := -1;
    end;

{$S Init}
    procedure SetFCommand (command: OSType; cmdproc: procptr);
{ procedure cmdproc }
        var
            i: integer;
    begin
        for i := 1 to convert_count do
            with converts^^[i] do
                if cmd = command then
                    cmdp := cmdproc;
    end;

{$S Init}
    procedure SetFSetMenu (command: OSType; smproc: procptr);
{ procedure smproc }
        var
            i: integer;
    begin
        for i := 1 to convert_count do
            with converts^^[i] do
                if cmd = command then
                    smp := smproc;
    end;

{$S Init}
    procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
{ procedure smproc }
        var
            i: integer;
    begin
        for i := 1 to convert_count do
            with converts^^[i] do
                if cmd = command then begin
                    cmdp := cmdproc;
                    smp := smproc;
                end;
    end;

{$S}
    procedure GetCommand (themenu, theitem: integer; var command: OSType);
        var
            i: integer;
    begin
        FindMenu(themenu, theitem, i);
        if i = -1 then
            command := 'xxx0'
        else
            command := converts^^[i].cmd;
    end;

{$S}
    procedure DoCmd (themenu, theitem: integer; cmdp: procptr);
    begin
        if cmdp = defaultproc then
            DoDefCMDP(themenu, theitem, cmdp)
        else
            DoCMDP(cmdp);
    end;

{$S}
    procedure DoCommand (themenu, theitem: integer; command: OSType);
        var
            cmdproc: procptr;
    begin
        FindCommand(command, cmdproc);
        DoCmd(themenu, theitem, cmdproc);
    end;

{$S}
    procedure DoFMenu (themenu, theitem: integer);
        var
            i: integer;
    begin
        FindMenu(themenu, theitem, i);
        if i = -1 then
            DoCmd(themenu, theitem, defaultproc)
        else
            with converts^^[i] do
                DoCmd(themenu, theitem, cmdp);
        if not quitNow then
            HiliteMenu(0);
    end;

{$S}
    procedure SetFMenus;
        var
            i: integer;
    begin
        for i := 1 to convert_count do
            with converts^^[i] do
                if smp <> nil then
                    DoSMP(menu, item, smp);
    end;

end.